home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / example.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  6.0 KB  |  193 lines  |  [TEXT/CCL2]
  1. ;;; example.lisp
  2. ;;;
  3. ;;; Example file showing one way to save person records
  4. ;;; in a persistent heap.
  5.  
  6. (in-package :wood)
  7.  
  8. ;; define the PERSON class
  9. (defclass person ()
  10.   ((first-name
  11.     :initarg :first-name
  12.     :accessor person-first-name)
  13.    (last-name
  14.     :initarg :last-name
  15.     :accessor person-last-name)
  16.    (age
  17.     :initarg :age
  18.     :accessor person-age)
  19.    (sex
  20.     :initarg :sex
  21.     :accessor person-sex)
  22.    (occupation
  23.     :initarg :occupation
  24.     :accessor person-occupation)
  25.    (ss#
  26.     :initarg :ss#
  27.     :accessor person-ss#)))
  28.  
  29. (defmethod person-name ((self person))
  30.   (concatenate 'string (person-first-name self) " " (person-last-name self)))
  31.  
  32. (defmethod print-object ((object person) stream)
  33.   (print-unreadable-object (object stream :type t :identity t)
  34.     (format stream "~a ~a, ~a"
  35.             (person-first-name object)
  36.             (person-last-name object)
  37.             (person-occupation object))))
  38.  
  39. ;; Create a persistent heap for storing indexed PERSON instances.
  40. ;; The root object is a three element list.
  41. ;; The first element identifies the file.
  42. ;; The second element is a btree mapping social security number to person.
  43. ;; The third element is a btree mapping last name to a list of people.
  44. (defun create-person-file (&key (filename "People.wood")
  45.                                 (if-exists :error))
  46.   (let ((pheap (open-pheap filename 
  47.                            :if-exists if-exists
  48.                            :if-does-not-exist :create)))
  49.     (setf (root-object pheap)
  50.           (p-list pheap
  51.                   "People"              ; Identify this file
  52.                   (p-make-btree pheap)          ; ss# -> person
  53.                   (p-make-btree pheap)          ; last-name -> (person ...)
  54.                   ))
  55.     pheap))
  56.  
  57. ; I wouldn't really look up the root for every access in a production system.
  58. (defun person-pheap-tables (pheap)
  59.   (let ((root (p-load (root-object pheap))))
  60.     (unless (and (listp root)
  61.                (eql 3 (length root))
  62.                (equal "People" (first root))
  63.                (p-btree-p (second root))
  64.                (p-btree-p (third root)))
  65.       (error "~s does not appear to be a person file" pheap))
  66.     (values (second root) (third root))))
  67.  
  68. (defun store-person (pheap person)
  69.   (setq person (require-type person 'person))
  70.   (multiple-value-bind (ss#->person last-name->person-list)
  71.                        (person-pheap-tables pheap)
  72.     (let ((ss# (person-ss# person))
  73.           (last-name (string-upcase (person-last-name person))))
  74.       (unless (p-btree-lookup ss#->person ss#)
  75.         (setf (p-btree-lookup ss#->person (person-ss# person)) person
  76.               (p-btree-lookup last-name->person-list last-name)
  77.               (cons person
  78.                     (p-load (p-btree-lookup last-name->person-list last-name)))))))
  79.   person)
  80.  
  81. (defun find-person-with-ss# (pheap ss#)
  82.   (let ((ss#->person (person-pheap-tables pheap)))
  83.     (p-load (p-btree-lookup ss#->person ss#))))
  84.  
  85. (defun find-people-with-last-name (pheap last-name)
  86.   (multiple-value-bind (ss#->person last-name->person-list)
  87.                        (person-pheap-tables pheap)
  88.     (declare (ignore ss#->person))
  89.     (p-load (p-btree-lookup last-name->person-list (string-upcase last-name)))))
  90.  
  91. (defun print-people-by-ss# (pheap)
  92.   (let ((ss#->person (person-pheap-tables pheap)))
  93.     (p-map-btree ss#->person
  94.                  #'(lambda (ss# person)
  95.                      (format t "~&~a ~s~%" ss# (p-load person))))))
  96.  
  97. (defun print-people-by-last-name (pheap)
  98.   (multiple-value-bind (ss#->person last-name->person-list)
  99.                        (person-pheap-tables pheap)
  100.     (declare (ignore ss#->person))
  101.     (p-map-btree last-name->person-list
  102.                  #'(lambda (last-name person-list)
  103.                      (declare (ignore last-name))
  104.                      (setq person-list
  105.                            (sort (mapcar 'p-load (p-load person-list))
  106.                                  #'string<
  107.                                  :key 'person-first-name))
  108.                      (dolist (person person-list)
  109.                        (format t "~&~s~%" person))))))
  110.  
  111. ;; Code for creating random PERSON instances.
  112. (defparameter *first-names*
  113.   '(("Alan" . M)
  114.     ("Abraham" . M)
  115.     ("Andrew" . M)
  116.     ("Alice" . F)
  117.     ("Susan" . F)
  118.     ("Bob" . M)
  119.     ("Hillary" . F)
  120.     ("Joe" . M)
  121.     ("Bill" . M)
  122.     ("Matthew" . M)
  123.     ("Gail" . F)
  124.     ("Gary" . M)
  125.     ("Doug" . M)
  126.     ("Christie" . F)
  127.     ("Steve" . M)
  128.     ("Elizabeth" . F)
  129.     ("Melissa" . F)
  130.     ("Karla" . F)
  131.     ("Dan" . M)
  132.     ("Irving" . M)))
  133.  
  134. (defparameter *last-names*
  135.   '("Smith" "Jones" "Peterson" "Williams" "Kennedy" "Johnson"
  136.     "Riley" "Sylversteen" "Wilson" "Cranshaw" "Ryan" "O'Neil"
  137.     "McAllister"))
  138.  
  139. (defparameter *occupations*
  140.   '("Butcher" "Baker" "Candlestick Maker"
  141.     "Engineer" "Hacker" "Tailor" "Cop" "Lawyer" "Doctor"
  142.     "Dentist" "Politician" "Cashier" "Insurance Sales"
  143.     "Advertising"))
  144.  
  145. (defun random-person ()
  146.   (multiple-value-bind (first-name last-name sex) (random-name)
  147.     (make-instance 'person
  148.       :first-name first-name
  149.       :last-name last-name
  150.       :sex sex
  151.       :age (random 100)
  152.       :occupation (random-element *occupations*)
  153.       :ss# (random-ss#))))
  154.  
  155. (defun random-element (sequence)
  156.   (elt sequence (random (length sequence))))
  157.     
  158. (defun random-name ()
  159.   (let ((first.sex (random-element *first-names*))
  160.         (last (random-element *last-names*)))
  161.     (values
  162.      (car first.sex) 
  163.      last
  164.      (cdr first.sex))))
  165.  
  166. (defvar *ss#s* (make-hash-table :test 'equal))
  167.  
  168. (defun random-ss# ()
  169.   (with-standard-io-syntax
  170.     (loop
  171.       (let ((ss# (write-to-string
  172.                   (+ (expt 10 8) (random (- (expt 10 9) (expt 10 8)))))))
  173.         (unless (gethash ss# *ss#s*)
  174.           (return
  175.            (setf (gethash ss# *ss#s*) ss#)))))))
  176.  
  177. (defun store-n-random-people (pheap n)
  178.   (dotimes (i n)
  179.     (store-person pheap (random-person))))
  180.  
  181. #|
  182. (defparameter *p* (create-person-file :if-exists :supersede)
  183. ; or
  184. (defparameter *p* (open-pheap "People.wood"))
  185.  
  186. (store-n-random-people 100)
  187.  
  188. (print-people-by-ss# *p*)
  189.  
  190. (print-people-by-last-name *p*)
  191.  
  192. (close-pheap *p*)
  193. |#